home *** CD-ROM | disk | FTP | other *** search
/ Games of Daze / Infomagic - Games of Daze (Summer 1995) (Disc 1 of 2).iso / x2ftp / msdos / libs / 3dvect39 / qb / stone.bas < prev    next >
BASIC Source File  |  1994-10-30  |  4KB  |  224 lines
  1. CLS
  2. RANDOMIZE
  3. DIM a(1000), b(1000)
  4. DIM hh(1000)
  5.  
  6. newparams:
  7. SCREEN 0
  8. WIDTH 80, 50
  9. CLS
  10.  
  11. INPUT " Start Pel              : "; qaa
  12. INPUT " Range        default 8 : "; qqb
  13. IF d$ = "" THEN INPUT " Palette     def 32.pal : "; d$
  14.  
  15. INPUT " Length of table def 500:"; ggh
  16. INPUT " Y Variance      def 100:"; yvar
  17. INPUT " Width           def 320:"; wd
  18.  
  19. INPUT " Dump file name (no extension!):"; c$
  20. INPUT " Dump starting character:"; h$
  21.  
  22. IF wd = 0 THEN wd = 320
  23. IF yvar = 0 THEN yvar = 100
  24.  
  25. IF ggh = 0 THEN ggh = 500
  26. IF yvar = 0 THEN yvar = 100
  27.  
  28. IF qqb < 2 THEN qqb = 8
  29. IF d$ = "" THEN d$ = "32.pal"
  30.  
  31. IF c$ = "" THEN c$ = "stone32"
  32.  
  33. SCREEN 13: DEF SEG = &HA000
  34.  
  35. GOSUB getpal
  36.  
  37. again:
  38. a(0) = RND(1) * qqb + qaa
  39. FOR x = 1 TO ggh
  40. kkkjj:
  41.  a(x) = INT(RND(1) * qqb + qaa)
  42.  b(x) = a(x)
  43.  IF ABS(a(x) - a(x - 1)) <= 0 THEN GOTO kkkjj
  44. NEXT x
  45.  
  46. g = 0
  47. h = 0
  48. i = 0
  49. j = 0
  50. k = 0
  51. q = 0
  52.  
  53. FOR x = 1 TO wd
  54. eerr:
  55.  q = q + 1
  56.  n = RND(1) * (yvar - 5)
  57.  IF ABS(g - n) < yvar / 3 THEN GOTO eerr
  58.  IF q > 5 THEN GOTO oks
  59.  IF ABS(h - n) < yvar / 6 THEN GOTO eerr
  60.  IF ABS(i - n) < yvar / 8 THEN GOTO eerr
  61.  IF ABS(j - n) < yvar / 10 THEN GOTO eerr
  62.  IF ABS(k - n) < yvar / 10 THEN GOTO eerr
  63. oks:
  64.  k = j
  65.  j = i
  66.  i = h
  67.  h = g
  68.  g = n
  69.  hh(x) = INT(n)
  70.  
  71. NEXT x
  72.  
  73. intensity = 256: ' used for darken
  74. level = 0
  75.  
  76. redraw:
  77.  
  78. hhj = wd
  79. 'IF hhj > 320 THEN hhj = 320
  80.  
  81. FOR x = 0 TO hhj - 1
  82.  FOR y = 0 TO 200
  83.   h = x + y * 320&
  84.   q = hh(x + 1) + y + level
  85.   POKE h, a(q + 1)
  86.  NEXT y
  87. oop:
  88. x$ = INKEY$
  89. IF x$ <> "" THEN GOTO aborted
  90. NEXT x
  91.  
  92. LOCATE 1, 1
  93. FOR z = 1 TO 20 * RND(1): PRINT "": NEXT z
  94. PRINT "s=save, space=recycle, q=quit"
  95. PRINT "r=redraw,d=color down, u=color up"
  96. PRINT "[=view bottom,]= view top."
  97. PRINT "+ - start pel up/down"
  98.  
  99. llkk:
  100. DO
  101. x$ = INKEY$
  102. LOOP WHILE x$ = ""
  103. aborted:
  104. IF x$ = " " THEN GOTO again
  105. IF x$ = "r" THEN GOTO redraw
  106. IF x$ = "d" THEN GOTO darken
  107. IF x$ = "u" THEN GOTO light
  108. IF x$ = "a" THEN GOTO newparams
  109. IF x$ = "q" THEN END
  110. IF x$ = "s" THEN GOTO filesave
  111. IF x$ = "[" THEN GOTO light3
  112. IF x$ = "]" THEN GOTO light4
  113. IF x$ = "+" THEN GOTO mainup
  114. IF x$ = "-" THEN GOTO maindown
  115.  
  116. GOTO llkk
  117.  
  118. light3:
  119.  level = 200
  120.  GOTO redraw
  121. light4:
  122.  level = 0
  123.  GOTO redraw
  124.  
  125. darken:
  126.  intensity = intensity - 3
  127.  IF intensity <= 0 THEN intensity = 256
  128.  GOTO kkll2
  129. light:
  130.  intensity = intensity + 3
  131.  IF intensity >= 256 THEN intensity = 0
  132. kkll2:
  133.  FOR z = 0 TO ggh
  134.   a(z) = INT((b(z) - qaa) / 256 * intensity + qaa)
  135.  NEXT z
  136. GOTO redraw
  137.  
  138. mainup:
  139. FOR z = 0 TO ggh
  140. b(z) = b(z) + 1
  141. NEXT z
  142. GOTO kkll2
  143.  
  144. maindown:
  145. FOR z = 0 TO ggh
  146. b(z) = b(z) - 1
  147. NEXT z
  148. GOTO kkll2
  149.  
  150. filesave:
  151. SCREEN 0
  152. WIDTH 80, 50
  153.  
  154. q$ = c$ + h$ + ".inc"
  155.  
  156. OPEN q$ FOR OUTPUT AS #1
  157.  
  158.  PRINT #1, "header"; h$; " dd offset stonel"; h$; " - offset $"
  159.  PRINT #1, "        dd offset stoney"; h$; " - offset $"
  160.  PRINT #1, ""
  161.  PRINT #1, "stonel"; h$; " db ";
  162.  
  163.   z = 1
  164.   FOR c = 1 TO ggh
  165.    PRINT #1, LTRIM$(RTRIM$(STR$(a(c))));
  166.    z = z + 1
  167.    IF z = 17 AND c <> ggh THEN z = 1: PRINT #1, "": PRINT #1, "        db "; : GOTO hhggff
  168.    IF c <> ggh THEN PRINT #1, ",";
  169. hhggff:
  170.   NEXT c
  171.  
  172.  PRINT #1, ""
  173.  PRINT #1, ""
  174.  PRINT #1, "stoney"; h$; " db ";
  175.  
  176.  c = ASC(h$)
  177.  c = c + 1
  178.  IF c = 58 THEN c = 97
  179.  h$ = CHR$(c)
  180.  
  181.   z = 1
  182.   FOR c = 1 TO wd
  183.    PRINT #1, LTRIM$(RTRIM$(STR$(hh(c))));
  184.    z = z + 1
  185.    IF z = 17 AND c <> wd THEN z = 1: PRINT #1, "": PRINT #1, "        db "; : GOTO hhggff2
  186.    IF c <> wd THEN PRINT #1, ",";
  187. hhggff2:
  188.   NEXT c
  189.  
  190. PRINT #1, ""
  191. PRINT #1, ""
  192. CLOSE #1
  193.  
  194. PRINT " File saved as:"; q$
  195. PRINT ""
  196. PRINT " n = new parameters"
  197. PRINT " c = continue with old"
  198. PRINT " q = quit"
  199.  
  200. llkkf:
  201. DO
  202. x$ = INKEY$
  203. LOOP WHILE x$ = ""
  204.  
  205. IF x$ = "n" THEN GOTO newparams
  206. IF x$ = "c" THEN SCREEN 13: GOSUB getpal: GOTO redraw
  207. IF x$ = "q" THEN END
  208. GOTO llkkf
  209. END
  210.  
  211. getpal:
  212. OPEN d$ FOR BINARY AS #1
  213.  
  214. P$ = SPACE$(256 * 3): GET #1, , P$
  215. OUT &H3C7, 0: OUT &H3C8, 0
  216. FOR a = 1 TO 256 * 3: OUT &H3C9, ASC(MID$(P$, a, 1)): NEXT
  217.  
  218. CLOSE #1
  219. RETURN
  220.  
  221.  
  222.  
  223.  
  224.